Windows Expert/Windows Expert.iso/program/dprin101.zip/DPRINT.PAS

Pascal/Delphi Source File | 1992-05-17 | 7KB | 255 lines

{*************************************************************

   Unit DPrint « for Turbo Pascal for Windows

   Copyright ⌐ 1992 by :

        PHADE SOFTWARE
        Inh. Frank Gadegast
        Leibnizstr. 30
        1000 Berlin 12 GERMANY

        Tel. : [phone]

    Version 1.01 / 17.5.92

**************************************************************}

unit dprint;

{--------------------------------------------------------------------------------}
{--------------------------------------------------------------------------------}

interface

uses    WObjects, WinTypes, WinProcs, Strings;

const
    prn_print    = 101;
    prn_cancel    = 102;
    prn_setup    = 103;
    prn_control    = 104;
    prn_list    = 105;

    prn_text    = 101;

type
    PSetupDialog = ^TSetupDialog;
    TSetupDialog = object (TDialog)
        theList    :    PChar;

        constructor Init (AParent : PWindowsObject; AName : PChar; thePrinters : PChar);
        procedure SetupWindow; virtual;
        procedure Print (var Msg : TMessage); virtual id_First + prn_print;
        procedure CancelDlg (var Msg : TMessage); virtual id_First + prn_cancel;
        procedure Setup (var Msg : TMessage); virtual id_First + prn_setup;
        procedure Control (var Msg : TMessage); virtual id_First + prn_control;
    end;

function PrinterSetup (ParWnd : HWnd) : boolean;

{--------------------------------------------------------------------------------}
{--------------------------------------------------------------------------------}

implementation

{$R dprint.res}

var
    setupup        : boolean;
    setupcancel    : boolean;

{--------------------------------------------------------------------------------}
{--------------------------------------------------------------------------------}

function strtoc (str : PChar; tok : char; count : integer) : PChar;

var i, word            : integer;
    tempsrc            : PChar;
    tempb, tempe    : PChar;

begin
    tempsrc := StrNew (str);
    tempe := strscan (tempsrc, tok);
    tempb := tempsrc;
    word := 1;
    for i := 0 to strlen (str) do
    begin
        if word = count then
        begin
            if tempe <> nil then
            begin
                tempe^ := #0;
                   strtoc := tempb;
            end
            else tempe := strend (tempb);
            strtoc := tempb;
        end
        else
        if tempsrc [i] = tok then
        begin
            inc (word);
            inc (i);
            tempb := PChar (addr (tempsrc [i]));
            tempe := strscan (tempb, tok);
        end;
    end;
end;

{--------------------------------------------------------------------------------}
{--------------------------------------------------------------------------------}

constructor TSetupDialog.Init (AParent : PWindowsObject; AName : PChar;
                                thePrinters : PChar);
begin
    TDialog.Init (AParent, AName);
    theList := thePrinters;
end;

{--------------------------------------------------------------------------------}

procedure TSetupDialog.SetupWindow;

var cur            : PChar;
    index        : integer;
    szPrinter    : array [0..64] of char;
    pDevice        : PChar;

begin
    TDialog.SetupWindow;
    cur := theList;
    while cur^ <> #0 do
    begin
        SendDlgItemMsg (prn_list, LB_ADDSTRING, 0, LongInt (cur));
        cur := cur + strlen (cur) + 1;
    end;
    if GetProfileString
        ('windows', 'device', '', szPrinter, sizeof (szprinter)) <> 0 then
    begin
        pDevice := strtoc (szPrinter, ',', 1);
        index := SendDlgItemMsg (prn_list, LB_FINDSTRING, 0, LongInt (pDevice));
        if index > -1 then SendDlgItemMsg (prn_list, LB_SETCURSEL, index, 0);
    end
    else SendDlgItemMsg (prn_list, LB_SETCURSEL, index, 0);

end;

{--------------------------------------------------------------------------------}

procedure TSetupDialog.Print (var Msg : TMessage);

var index        : integer;
    szPrinter    : array [0..64] of char;
    szDevice    : PChar;

begin
    szDevice := Strnew ('                                                  ');
    index := SendDlgItemMsg (prn_list, LB_GETCURSEL, 0, 0);
    if index <> lb_err then
    begin
        SendDlgItemMsg (prn_list, LB_GETTEXT, index, LongInt (szDevice));
        GetProfileString ('devices', szDevice, '', szPrinter, sizeof (szPrinter));
        strcat (szdevice, ',');
        strcat (szdevice, szPrinter);
        WriteProfileString ('windows', 'device', szDevice);
        EndDlg (0);
    end
    else
    begin
        MessageBox (HWindow, 'No printer selected !',
            'Print Error', mb_Ok or mb_IconStop);
    end;
end;

{--------------------------------------------------------------------------------}

procedure TSetupDialog.CancelDlg (var Msg : TMessage);
begin
    TDialog.EndDlg (0);
    setupcancel := true;
end;

{--------------------------------------------------------------------------------}

procedure TSetupDialog.Setup (var Msg : TMessage);

type TDevFunc = function (hw : HWnd; th : THandle; pd : LongInt; po : LongInt) : integer;

var index        : integer;
    curDev        : PChar;
    szDevice    : array [0..64] of char;
    szDriver    : array [0..64] of char;
    pDevice,
    pDriver,
    pOutput        : PChar;
    hDriver     : THandle;
    DevFunc        : TDevFunc;
    fpDevMode    : TFarProc ;

begin
       curDev := Strnew ('                                                  ');
    index := SendDlgItemMsg (prn_list, LB_GETCURSEL, 0, 0);
    if index <> lb_err then
    begin
        SendDlgItemMsg (prn_list, LB_GETTEXT, index, LongInt (curdev));
        GetProfileString ('devices', curdev, '', szdevice, sizeof (szdevice));
        pDriver := strtoc (szdevice, ',', 1);
        pOutput := strtoc (szdevice, ',', 2);
        pDevice := curdev;
        strcopy (szDriver, pDriver);
        strcat (szDriver, '.DRV');

        hDriver := LoadLibrary (szDriver);
        if hDriver < 32 then exit;

        fpDevMode := GetProcAddress (hDriver, 'DeviceMode');
        if fpDevMode = nil then
           begin
            FreeLibrary (hDriver);
            exit;
           end;

        DevFunc := TDevFunc (fpDevMode);
        DevFunc (getfocus, hDriver, LongInt (pDevice), LongInt (pOutput));

        FreeLibrary (hDriver);
    end;
end;

{--------------------------------------------------------------------------------}

procedure TSetupDialog.Control (var Msg : TMessage);

begin
    WinExec ('CONTROL.EXE', sw_ShowNormal);
end;

{--------------------------------------------------------------------------------}

function PrinterSetup (ParWnd : HWnd) : boolean;

var szDevices    : array [0..2048] of char;
    dlgret        : integer;

begin
    if setupup = true then PrinterSetup := false
    else
    begin
        setupup := true;
        setupcancel := false;
        GetProfileString ('devices', nil, '', szdevices, sizeof (szdevices));
        Application^.Execdialog (new (PSetupDialog,
            Init (Application^.MainWindow, 'PRINTERSETUP', szdevices)));
        PrinterSetup := not setupcancel;
        EnableWindow (ParWnd, true);
        setupup := false;
    end;
end;

{--------------------------------------------------------------------------------}
{--------------------------------------------------------------------------------}

begin
    setupup := false;
end.